Internet Info 1994 March/Internet Info CD-ROM (Walnut Creek) (March 1994).iso/networking/terms/kermit/c/pq2con.pas

Pascal/Delphi Source File | 1988-08-16 | 11.5 KB | 417 lines

module KermitConnect;

{
{   Module for simulating a terminal.
{
{       The correct communications parameters must have
{   been set up before this routine is used.
{                                                       }

{===========================} exports {====================================}

imports FileDefs from FileDefs;

procedure   Terminal( EscChar : Char );
procedure   SetSaveFile( NewSaveFile : PathName );

{===========================} private {====================================}

imports MenuUtils from MenuUtils;
imports system from system;
imports FileSystem from FileSystem;
imports IO_Unit from IO_Unit;
imports IOErrors from IOErrors;
imports IOUtils from IOUtils;

{   own modules:   }
imports KermitScreen from KermitScreen;
imports KermitLineIO from KermitLineIO;
imports KermitParameters from KermitParameters;

{----------------------------------------------------------------------------}

const   BBuffSize   =   512;    { number of bytes in FS-block }

{----------------------------------------------------------------------------}

var
        BuffPtr     :   PDirBlk;
        BufferIndex :   -1..BBuffSize;
        BlockNumber :   FirstBlk..LastBlk;
        Id          :   FileID;
        GetC,SendC  :   char;
        LineIndex   :   integer;
        TermMenu, SpeedMenu, ParityMenu, StopMenu : pNameDesc;

{----------------------------------------------------------------------------}
{
procedure   FlushBuffer;
var     i : integer;
begin
    for i:=MinBuffIndex to BufferIndex do
        write(SaveFile,Buffer[i]);
    BufferIndex:=MinBuffIndex - 1;
end;
}

{----------------------------------------------------------------------------}

procedure   SaveInBuffer(ch:char);
begin
    if BufferIndex = BBuffSize - 1 then
    begin
        FSBlkWrite(Id,BlockNumber,BuffPtr);
        BlockNumber := BlockNumber + 1;
        BufferIndex:=-1;
    {   if XonXoff then RSPutChar(XOn);  }
    end;
    BufferIndex:=BufferIndex+1;
    BuffPtr^.ByteBuffer[BufferIndex]:=ord(ch);
end;


{----------------------------------------------------------------------------}

procedure OpenSave;
begin
    Id := FSEnter( SaveFile );
    if Id = 0 then begin
        PutMessage('*** Illegal Log File name ***');
        SaveFile := '';
    end
    else
    begin
        BlockNumber := FirstBlk;
        BufferIndex:= - 1;
    end;
    SwitchWindow( MainWindow );
end; { OpenSave }


{----------------------------------------------------------------------------}

procedure CloseSave;
begin
    if BufferIndex >= 0 then
    begin
         { The last block is partially full }
       FSBlkWrite(Id,BlockNumber,BuffPtr);
       FSClose(Id,BlockNumber,(BufferIndex+1)*8);
         { last parameter is number of bits in last block }
    end else
         { The last block is FULL }
        FSClose(Id,BlockNumber-1,BBuffSize*8);
end; { CloseSave }


{----------------------------------------------------------------------------}

procedure SetSaveFile( NewSaveFile : PathName );
begin
    if SaveFile<>'' then
        CloseSave;
    SaveFile := NewSaveFile;
    if SaveFile<>'' then
        OpenSave;
end;


{----------------------------------------------------------------------------}

procedure ChangeSaveFile;
var NewSaveFile : PathName;
    CurrWin : WinType;
begin
    CurrentWindow( CurrWin );
    SwitchWindow( MessageWindow );
    write( 'Enter name of new log file : ' );
    readln( NewSaveFile );
    SetSaveFile( NewSaveFile );
    SwitchWindow( CurrWin );
end;


{----------------------------------------------------------------------------}

procedure   TreatIncoming(ch:char);
begin
    case ch of
        BS  :   if LineIndex >= 1 then
                    BackSpace(' ')
                else
                    write('');
        CR  :   begin
                    LineIndex := 0;
                    if FileSave and not (SaveFile='') then
                        SaveInBuffer(ch);
                    PutChr(chr( LAnd( ord(ch), 127 )));
                end;
        NULL :  ;
        otherwise :
                begin
                    LineIndex := LineIndex + 1;
                    if FileSave and not (SaveFile='') then
                        SaveInBuffer(ch);
                    PutChr(chr( LAnd( ord(ch), 127 )));
                end;
    end;
end;


{----------------------------------------------------------------------------}

function    Xlat(ch:char): char;
var
        Res : char;
begin
    if ( LAnd(ord(ch),#200) <> 0 ) then  { control-character }
        Res := chr(LAnd(ord(ch),#37))
    else
        Res := ch;

    Xlat := Res;
end;


{----------------------------------------------------------------------------}

procedure EscHelp;
begin
    SwitchWindow( MainWindow );
    writeln;
    writeln(' ? - This message' );
    writeln(' C - Close connection, return to Perq' );
    writeln(' B - Send break' );
    writeln(' 0 - Send a NUL' );
    writeln(' Q - Quit (turn off) logging to a file' );
    writeln(' R - Resume (turn on) logging to a file' );
    writeln;
    writeln('Typing the escape character will send it to the remote computer');
    write  ('Command>');
end;

{----------------------------------------------------------------------------}

function    MakeUpper(ch:char): char;
var
        Res : char;
begin
    Res := Ch;
    if ( LAnd(ord(ch),#200) <> 0 ) then  { control-character }
        Res := chr(LAnd(ord(ch),#177));
    if ch in ['a'..'z'] then
        Res := chr( ord(ch) - (ord('a') - ord('A')) );

    MakeUpper := Res;
end;


{----------------------------------------------------------------------------}

procedure   DoSetBaud;

    function    GetBaud:SpeedType;
    begin  { GetBaud }
        GetBaud := recast(GetMenuAnswer(SpeedMenu,200),SpeedType);
    end; { GetBaud }

begin
    Baud := GetBaud;
    RefreshBaud;
end;


{----------------------------------------------------------------------------}

procedure   DoSetParity;

    function GetKerParity:ParityType;
    begin
        GetKerParity := recast(GetMenuAnswer(ParityMenu,150),ParityType);
    end;

begin
    Parity := GetKerParity;
    RefreshParity;
end;


{----------------------------------------------------------------------------}

procedure   DoSetStop;

    function GetStop:StopType;
    begin
        GetStop := recast(GetMenuAnswer(StopMenu,150),StopType);
    end;

begin
    StopBits := GetStop;
    RefreshStopBits;
end;


{----------------------------------------------------------------------------}

procedure   InitTMenu;
var SetMenu : pMenuEntry;
begin
    AllocNameDesc( NTermComm, 0, TermMenu );
    {$range-}
    with TermMenu^ do begin
        Header := 'Terminal commands';
        Commands[ord(TermHelp)      ] := '?';
        Commands[ord(TermQuit)      ] := 'QUIT terminal mode';
        Commands[ord(TermSetBaud)   ] := 'set BAUD';
        Commands[ord(TermSetStop)   ] := 'set STOP-BITS';
        Commands[ord(TermSetParity) ] := 'set PARITY';
        Commands[ord(TermSaveFile)  ] := 'set LOG-FILE';
        Commands[ord(TermOnSave)    ] := 'set LOG ON';
        Commands[ord(TermOffSave)   ] := 'set LOG OFF';
        Commands[ord(TermOnXonXoff) ] := 'set XON-XOFF ON';
        Commands[ord(TermOffXonXoff)] := 'set XON-XOFF OFF';
    end;
    SetMenu := RootMenu^.NextLevel[ ord( MainSet ) ];
    with SetMenu^ do begin
        SpeedMenu  := NextLevel[ ord( SetBaud ) ]^.MPtr;
        ParityMenu := NextLevel[ ord( SetParity ) ]^.MPtr;
        StopMenu   := NextLevel[ ord( SetStop ) ]^.MPtr;
    end;
    {$range=}
end;


{----------------------------------------------------------------------------}

procedure GiveHelp;
begin
    SwitchWindow( MainWindow );
    writeln;
    writeln(' Terminal commands: ');
    writeln;
    writeln('QUIT           - return to Kermit-Perq main command level');
    writeln('SET BAUD/STOP/PARITY - set line parameters');
    writeln('SET LOG-FILE   - enter name of file to log terminal session to');
    writeln('SET LOG ON/OFF - turn log output on/off');
    writeln('SET XON-XOFF ON/OFF  - use/respect XON/XOFF handshake');
    writeln;
    SwitchWindow( TermWindow );
end;


{----------------------------------------------------------------------------}

procedure   Terminal( EscChar : char );

var GetC, SendC         :   char;
    done, HelpPrompt    :   boolean;
    TComm               :   TermCommType;

    function    GetTermComm : TermCommType;
    begin
        GetTermComm:=recast(GetMenuAnswer(TermMenu,150),TermCommType);
    end;

    procedure DoTermComm( TComm : TermCommType );
    begin
        case TComm of
            TermHelp        :   GiveHelp;
            TermSetBaud     :   DoSetBaud;
            TermSetParity   :   DoSetParity;
            TermSetStop     :   DoSetStop;
            TermQuit        :   ;
            TermOnSave      :   FileSave := true;
            TermOffSave     :   FileSave := false;
            TermSaveFile    :   ChangeSaveFile;
            TermOnXonXoff   :   XonXoff := true;
            TermOffXonXoff  :   XonXoff := false;
        end;
    end;

    handler IOWrErr( IOStatus : integer );
    begin
       PutMessage('Write error on line (possibly unplugged RS232 connector)');
    end;

    handler IORdErr( IOStatus : integer );
    begin
       PutMessage('Read error on line (possibly wrong speed or parity)');
    end;

    handler CtlC;
    begin
        ctrlcpending := false;
    end;


begin
    XonXoff := true;    { enable handshake }
    BlockNumber := FirstBlk;
    new(BuffPtr);      {   Set up pointer to buffer    }
    InitTermScreen;
    InitTMenu;
    LineIndex := 0;
    done:=false;
    repeat

        if GetChar( Idev, GetC ) then
        { IO Complete on RS232-line }
            TreatIncoming(GetC);

        if IOCRead(KeyBoard,SendC) = IOEIOC then
        { IO Complete on keyboard }
        begin
            if SendC <> EscChar then begin
                    { Must handle conversion to ctrl-chars myself.
                        ^DEL = BREAK
                    }
                SendC:=Xlat(SendC);

                    { Send character on RS232-line }
                if SendC <> BreakKey then  { not a break? }
                    Outbt( Odev, SendC)
                else
                    SendBreak( 500 { milliseconds });
            end else begin
                HelpPrompt := false;
                repeat
                    while IOCRead( KeyBoard, SendC ) <> IOEIOC do ;
                    if HelpPrompt then begin
                        writeln;
                        ChangeWindow( TermWindow );
                    end;
                    if SendC=EscChar then begin
                        SendC := Xlat( SendC );
                        Outbt( Odev, SendC );
                    end else
                    begin
                        SendC := MakeUpper( SendC );
                        case SendC of
                            '0':    OutBt( Odev, chr(0) );
                            'B':    SendBreak( 500 );
                            'C':    TComm := TermQuit;
                            'Q':    FileSave := FALSE;
                            'R':    FileSave := TRUE;
                            '?':    begin
                                        EscHelp;
                                        HelpPrompt := true;
                                    end;
                            otherwise: write(Chr(7));
                        end;
                    end;
                until SendC<>'?';
            end;
        end;

        if TabSwitch then
        begin
            TComm:= GetTermComm;
            DoTermComm( TComm );
        end;

    until TComm = TermQuit;
    CleanupTermScreen;
    DestroyNameDescr( TermMenu);
end.